home *** CD-ROM | disk | FTP | other *** search
/ Disc to the Future 2 / Disc to the Future Part II Programmer's Reference (Wayzata Technology)(6013)(1992).bin / MAC / MPW_TOOL / TOOLS / TOOLS_WI / ICON_8 / ICONX_FO / IMAIN.C < prev    next >
C/C++ Source or Header  |  1990-04-08  |  39KB  |  1,657 lines
  1. /*
  2.  * Main program, initialization, termination, and such.
  3.  */
  4.  
  5. #include <math.h>
  6. #include "::h:config.h"
  7. #include "::h:rt.h"
  8. #include "rproto.h"
  9. #include "::h:version.h"
  10. #include "::h:header.h"
  11. #include "::h:opdefs.h"
  12. #include <ctype.h>
  13.  
  14. /*
  15.  * Prototype.
  16.  */
  17.  
  18. hidden    novalue    env_err    Params((char *msg,char *name,char *val));
  19.  
  20. /*
  21.  * The following code is operating-system dependent [@imain.01].  Include files
  22.  *  and declarations that are system-dependent.
  23.  */
  24.  
  25. #if PORT
  26. #include <signal.h>
  27.    /* probably needs something more */
  28. Deliberate Syntax Error
  29. #endif                    /* PORT */
  30.  
  31. #if AMIGA
  32. #include <signal.h>
  33. #include <fcntl.h>
  34.  
  35. int chkbreak;                /* if nonzero, check for ^C */
  36. #endif                    /* AMIGA */
  37.  
  38. #if ATARI_ST
  39. #include <fcntl.h>
  40. #endif                    /* ATARI_ST */
  41.  
  42. #if HIGHC_386
  43. #include <system.cf>
  44.  
  45. int _fmode = 0;            /* force CR-LF on std.. files */
  46. #endif                    /* HIGHC_386 */
  47.  
  48. #if MACINTOSH
  49. #include <signal.h>
  50. #if MPW
  51. #include <Types.h>
  52. #include <Events.h>
  53. #include <FCntl.h>
  54. #include <SANE.h>
  55. #include <CursorCtl.h>
  56. int NoOptions = 0;
  57. #endif                    /* MPW */
  58. #endif                    /* MACINTOSH */
  59.  
  60. #if MSDOS
  61. #if !MWC
  62. #include <fcntl.h>
  63. #include <signal.h>
  64. #endif                    /* !MWC */
  65.  
  66. #if MICROSOFT
  67. #include <fcntl.h>
  68. #include <signal.h>
  69. #endif                    /* MICROSOFT */
  70. #endif                    /* MSDOS */
  71.  
  72. #if MVS || VM
  73. #include <signal.h>
  74. #endif                    /* MVS || VM */
  75.  
  76. #if OS2
  77. #include <fcntl.h>
  78. #include <signal.h>
  79. #endif                    /* OS2 */
  80.  
  81. #if UNIX
  82. #include <signal.h>
  83. #endif                    /* UNIX */
  84.  
  85. #if VMS
  86. #include <types.h>
  87. #endif                    /* VMS */
  88.  
  89. static char icodebuf[BUFSIZ];
  90.  
  91. /*
  92.  * End of operating-system specific code.
  93.  */
  94.  
  95. #ifdef IconAlloc
  96. #define malloc mem_alloc
  97. #endif                    /* IconAlloc */
  98.  
  99. #ifndef MaxHeader
  100. #define MaxHeader MaxHdr
  101. #endif                    /* MaxHeader */
  102.  
  103. /*
  104.  * A number of important variables follow.
  105.  */
  106.  
  107. static struct b_coexpr *mainhead;    /* &main */
  108. extern struct errtab errtab[];        /* error numbers and messages */
  109.  
  110. #ifdef TraceBack
  111. extern struct b_proc *opblks[];
  112. extern word lastop;            /* last op-code */
  113. extern dptr xargp;
  114. extern word xnargs;            /* number of arguments */
  115.  
  116. #endif                    /* TraceBack */
  117.  
  118.  
  119. #ifdef EvalTrace
  120. word lineno = 0;            /* source line number */
  121. word colmno = 0;            /* source column number */
  122. #endif                    /* EvalTrace */
  123.  
  124. #ifdef DumpIstream
  125. FILE *imons;
  126. #endif                    /* DumpIstream */
  127.  
  128. #ifdef DumpIcount
  129. #define MaxIcode 100
  130. FILE *imonc;
  131. long icode[MaxIcode];
  132. #endif                    /* DumpIcount */
  133.  
  134.  
  135. #ifdef WATERLOO_C_V3_0
  136. extern int *cw3defect;
  137. #endif                    /* WATERLOO_C_V3_0 */
  138.  
  139. #ifdef IconCalling
  140. int IDepth = 0;                /* depth of icon_call calls */
  141. int call_error = 0;            /* called procedure not found */
  142. int interp_status;            /* interpreter status */
  143. #endif                    /* IconCalling */
  144.  
  145. int set_up = 0;                /* initialization switch */
  146. int k_level = 0;            /* &level */
  147. int k_errornumber = 0;            /* &errornumber */
  148. char *k_errortext = "";            /* &errortext */
  149. struct descrip k_errorvalue;        /* &errorvalue */
  150. struct descrip k_main;            /* &main */
  151. char *code;                /* interpreter code buffer */
  152. word *records;                /* pointer to record procedure blocks */
  153. word *ftabp;                /* pointer to record/field table */
  154. dptr fnames, efnames;            /* pointer to field names */
  155. dptr globals, eglobals;            /* pointer to global variables */
  156. dptr gnames, egnames;            /* pointer to global variable names */
  157. dptr statics, estatics;            /* pointer to static variables */
  158. char *strcons;                /* pointer to string constant table */
  159. struct ipc_fname *filenms, *efilenms;    /* pointer to ipc/file name table */
  160. struct ipc_line *ilines, *elines;    /* pointer to ipc/line number table */
  161.  
  162. #ifdef TallyOpt
  163. word tallybin[16];            /* counters for tallying */
  164. int tallyopt = 0;            /* want tally results output? */
  165. #endif                    /* TallyOpt */
  166.  
  167. word mstksize = MStackSize;        /* initial size of main stack */
  168. word stksize = StackSize;        /* co-expression stack size */
  169. struct b_coexpr *stklist;        /* base of co-expression block list */
  170.  
  171. word statsize = MaxStatSize;        /* size of static region */
  172. word statincr = MaxStatSize/4;        /* increment for static region */
  173. char *statbase = NULL;            /* start of static space */
  174. char *statend;                /* end of static space */
  175. char *statfree;                /* static space free pointer */
  176.  
  177. word ssize = MaxStrSpace;        /* initial string space size (bytes) */
  178. char *strbase;                /* start of string space */
  179. char *strend;                /* end of string space */
  180. char *strfree;                /* string space free pointer */
  181. char *currend = NULL;            /* current end of memory region */
  182.  
  183. word abrsize = MaxAbrSize;        /* initial size of allocated block
  184.                        region (bytes) */
  185. char *blkbase;                /* start of block region */
  186. char *blkend;                /* end of allocated blocks */
  187. char *blkfree;                /* block region free pointer */
  188.  
  189. #ifdef FixedRegions
  190. word qualsize = QualLstSize;        /* size of quallist for fixed regions */
  191. #endif                    /* FixedRegions */
  192.  
  193. uword statneed;                /* stated need for static space */
  194. uword strneed;                /* stated need for string space */
  195. uword blkneed;                /* stated need for block space */
  196.  
  197. int dodump;                /* if nonzero, core dump on error */
  198. int noerrbuf;                /* if nonzero, do not buffer stderr */
  199.  
  200. struct descrip k_current;        /* current expression stack pointer */
  201. struct descrip maps2;            /* second cached argument of map */
  202. struct descrip maps3;            /* third cached argument of map */
  203.  
  204. int ntended = 0;            /* number of active tended descrips */
  205. long starttime;                /* start time of job in milliseconds */
  206.  
  207. #ifdef ExecImages
  208. int dumped = 0;                /* non-zero if reloaded from dump */
  209. #endif                    /* ExecImages */
  210.  
  211. word *stack;                /* Interpreter stack */
  212. word *stackend;             /* End of interpreter stack */
  213.  
  214.  
  215.  
  216. /*
  217.  * Initial icode sequence. This is used to invoke the main procedure with one
  218.  *  argument.  If main returns, the Op_Quit is executed.
  219.  */
  220. word istart[3];
  221. int mterm = Op_Quit;
  222.  
  223. #ifdef IconCalling
  224. int fterm = Op_FQuit;
  225. #endif                    /* IconCalling */
  226.  
  227. #ifndef IconCalling
  228.  
  229.  
  230. novalue main(argc, argv)
  231.  
  232. int argc;
  233. char **argv;
  234.    {
  235.    int i, slen;
  236.  
  237.    ipc.opnd = NULL;
  238.  
  239.    /*
  240.     * Setup Icon interface.  It's done this way to avoid duplication
  241.     *  of code, since the same thing has to be done if calling Icon
  242.     *  is enabled.  See istart.c.
  243.     */
  244.  
  245.    icon_setup(argc, argv, &i);
  246.  #if MACINTOSH && MPW
  247.    if (i < 0) {
  248.       argc++;
  249.       argv--;
  250.       i++;
  251.       }
  252.  #endif                    /* MACINTOSH && MPW */
  253.    while (i--) {            /* skip option arguments */
  254.       argc--;
  255.       argv++;
  256.       }
  257.  
  258.    if (!argc) 
  259.       error("no icode file specified");
  260.    /*
  261.     * Call icon_init with the name of the icode file to execute.    [[I?]]
  262.     */
  263.  
  264.  
  265.    icon_init(argv[1]);
  266.  
  267.    /*
  268.     *  Point sp at word after b_coexpr block for &main, point ipc at initial
  269.     *    icode segment, and clear the gfp.
  270.     */
  271.    stackend = stack + mstksize/WordSize;
  272.    sp = stack + Wsizeof(struct b_coexpr);
  273.    ipc.opnd = istart;
  274.    *ipc.op++ = Op_Invoke;                /*    [[I?]] */
  275.    *ipc.opnd++ = 1;
  276.  
  277. #ifdef WATERLOO_C_V3_0
  278.    /*
  279.     *  Workaround for compiler bug.
  280.     */
  281.    cw3defect = ipc.op;
  282.    *cw3defect = Op_Quit;
  283. #else                    /* WATERLOO_C_V3_0 */
  284.    *ipc.op = Op_Quit;
  285. #endif                    /* WATERLOO_C_V3_0 */
  286.  
  287.    ipc.opnd = istart;
  288.    gfp = 0;
  289.  
  290.    /*
  291.     * Set up expression frame marker to contain execution of the
  292.     *  main procedure.  If failure occurs in this context, control
  293.     *  is transferred to mterm, the address of an Op_Quit.
  294.     */
  295.    efp = (struct ef_marker *)(sp);
  296.    efp->ef_failure.op = &mterm;
  297.    efp->ef_gfp = 0;
  298.    efp->ef_efp = 0;
  299.    efp->ef_ilevel = 1;
  300.    sp += Wsizeof(*efp) - 1;
  301.  
  302.    pfp = 0;
  303.    ilevel = 0;
  304.  
  305.    /*
  306.     * The first global variable holds the value of "main".  If it
  307.     *  is not of type procedure, this is noted as run-time error 117.
  308.     *  Otherwise, this value is pushed on the stack.
  309.     */
  310.    if (globals[0].dword != D_Proc)
  311.       fatalerr(-117, NULL);
  312.    PushDesc(globals[0]);
  313.  
  314.    /*
  315.     * Main is to be invoked with one argument, a list of the command
  316.     *  line arguments.    The command line arguments are pushed on the
  317.     *  stack as a series of descriptors and llist is called to create
  318.     *  the list.  The null descriptor first pushed serves as Arg0 for
  319.     *  Ollist and receives the result of the computation.
  320.     */
  321.    PushNull;
  322.    argp = (dptr)(sp - 1);
  323.    for (i = 2; i < argc; i++) {
  324.       slen = strlen(argv[i]);
  325.       strreq((word)slen);
  326.       PushVal(slen);
  327.       PushAVal(alcstr(argv[i],(word)slen));
  328.       }
  329.  
  330.    Ollist(argc - 2, argp);
  331.  
  332.    sp = (word *)argp + 1;
  333.    argp = 0;
  334.  
  335.    set_up = 1;            /* post fact that iconx is initialized */
  336.  
  337.    /*
  338.     * Start things rolling by calling interp.  This call to interp
  339.     *  returns only if an Op_Quit is executed.    If this happens,
  340.     *  c_exit() is called to wrap things up.
  341.     */
  342.  
  343.    interp(0,(dptr)NULL);
  344.  
  345.    c_exit(NormalExit);
  346. }
  347. #endif                    /* IconCalling */
  348.  
  349. #ifdef IconCalling
  350. dptr icon_call(pname, argc, dargv)
  351. char *pname;
  352. int argc;
  353. dptr dargv;
  354. {
  355.    int i;
  356.    dptr retdesc;
  357.    struct descrip pd;
  358.  
  359.    if (IDepth == 0)
  360.       {
  361.       /*
  362.        * Perform first-time initializations.
  363.        *  Point sp at word after b_coexpr block for &main, point ipc at initial
  364.        *  icode segment, and clear the gfp.
  365.        */
  366.       stackend = stack + mstksize/WordSize;
  367.       sp = stack + Wsizeof(struct b_coexpr);
  368.       sp--;   /* point at last thing on stack, not beyond it */
  369.  
  370.       interp_status = 0;
  371.       argp = 0;
  372.       pfp = 0;
  373.       ilevel = 0;
  374.       }
  375.  
  376.    /*
  377.     *  Point sp at word after b_coexpr block for &main, point ipc at initial
  378.     *    icode segment, and clear the gfp.
  379.     */
  380.    ipc.opnd = istart;
  381.    *ipc.op++ = Op_Invoke;
  382.    *ipc.opnd++ = argc;            /* number of arguments for call */
  383.  
  384. #ifdef WATERLOO_C_V3_0
  385.    /*
  386.     *  Workaround for compiler bug.
  387.     */
  388.    cw3defect = ipc.op;
  389.    *cw3defect = Op_Quit;
  390. #else                    /* WATERLOO_C_V3_0 */
  391.    *ipc.op = Op_Quit;
  392. #endif                    /* WATERLOO_C_V3_0 */
  393.  
  394.    ipc.opnd = istart;
  395.    gfp = 0;
  396.  
  397.    /*
  398.     * Set up expression frame marker to contain execution of the
  399.     *  main procedure.    If failure occurs in this context, control
  400.     *  is transferred to fterm, the address of an Op_FQuit.
  401.     */
  402.    efp = (struct ef_marker *)(sp + 1);
  403.    efp->ef_failure.op = &fterm;     /* signals a failure to interp */
  404.    efp->ef_gfp = 0;
  405.    efp->ef_efp = 0;
  406.    efp->ef_ilevel = ilevel + 1;
  407.    sp += Wsizeof(*efp);
  408.  
  409.    /*
  410.     * "main" is no longer the default starting procedure.
  411.     *  Use procedure named pname as the main (starting) procedure.
  412.     */
  413.    if (getvar(pname,&pd) == Failure) {
  414.       fprintf(stderr, "Icon function/procedure \"%s\" not found\n", pname);
  415.       fflush(stderr);
  416.       call_error = 1;
  417.       return (dptr)NULL;
  418.       }
  419.    DeRef(pd);            /* get value (can't fail) */
  420.  
  421.    /*
  422.     * Must be of type procedure.
  423.     */
  424.    if ((pd.dword != D_Proc)) { 
  425.       if (strcmp(pname,"main") == 0 && (pfp == 0))
  426.          fatalerr(-117, NULL);
  427.       else {
  428.          if (pfp == 0)
  429.             fatalerr(-106, NULL);
  430.          else
  431.             fatalerr(106, NULL);
  432.          }
  433.       }
  434.  
  435.    PushDesc(pd);
  436.  
  437.    /*
  438.     * The input arguments are pushed on the stack as a series
  439.     *  of descriptors and the indicated procedure.  The procedure descriptor
  440.     *  is overwritten with the result of the call.
  441.     */
  442.    for (i = 0; i < argc; i++) {           /* i = 0, instead of 2 */
  443.       PushDesc(dargv[i]);
  444.       }
  445.  
  446. /* Pass on value of argp to current invocation.  This will be 0 by
  447.  *  default on the first action, and the value of the current argp on
  448.  *  subsequent invocations.
  449.  */
  450.  
  451.    /*
  452.     * Start things rolling by calling interp.  This call to interp
  453.     *  returns only if an Op_Quit is executed.    If this happens,
  454.     *  return the result of main. (Used to c_exit here).
  455.     */
  456.    IDepth++;
  457.  
  458.    interp(0,(dptr)NULL);
  459.  
  460.    IDepth--;
  461.    if (interp_status == A_Pfail_uw)
  462.        return (dptr)NULL;        /* failure no value */
  463.    else                    /* NOTE: suspension not identified */
  464.        {
  465.        retdesc = (dptr)(sp - 1);
  466.        sp = (word *) efp - 1;
  467.        return retdesc;             /* success, return top sp */
  468.        }
  469.  
  470. }
  471. #endif                     /* IconCalling */
  472.  
  473. novalue icon_setup(argc,argv,ip)
  474. int argc;
  475. char **argv;
  476. int *ip;
  477.    {
  478.  
  479. #ifdef TallyOpt
  480.    extern int tallyopt;
  481. #endif                    /* TallyOpt */
  482.  
  483.    *ip = 0;            /* number of arguments processed */
  484.  
  485. #ifdef ExecImages
  486.    if (dumped) {
  487.       /*
  488.        * This is a restart of a dumped interpreter.  Normally, argv[0] is
  489.        *  iconx, argv[1] is the icode file, and argv[2:(argc-1)] are the
  490.        *  arguments to pass as a list to main().  For a dumped interpreter
  491.        *  however, argv[0] is the executable binary, and the first argument
  492.        *  for main() is argv[1].  The simplest way to handle this is to
  493.        *  back up argv to point at argv[-1] and increment argc, giving the
  494.        *  illusion of an additional argument at the head of the list.  Note
  495.        *  that this argument is never referenced.
  496.        */
  497.       argv--;
  498.       argc++;
  499.       (*ip)--;
  500.       }
  501. #endif                    /* ExecImages */
  502.  
  503. #ifdef MaxLevel
  504.    maxilevel = 0;
  505.    maxplevel = 0;
  506.    maxsp = 0;
  507. #endif                    /* MaxLevel */
  508.  
  509. #ifdef DumpIstream
  510.    imons = fopen("icodes.mon",WriteText);
  511.    if (imons == NULL) {
  512.       fprintf(stderr,"cannot open icodes.mon\n");
  513.       fflush(stderr);
  514.       abort();
  515.       }
  516. #endif                    /* DumpIstream */
  517.  
  518. #ifdef DumpIcount
  519.    imonc = fopen("icodec.mon",WriteText);
  520.    if (imonc == NULL) {
  521.       fprintf(stderr,"cannot open icodec.mon\n");
  522.       fflush(stderr);
  523.       abort();
  524.       }
  525. #endif                    /* DumpIcount */
  526.  
  527. #if VMS
  528.    redirect(&argc, argv, 0);
  529. #endif                    /* VMS */
  530.  
  531. #if MACINTOSH
  532. #if MPW
  533.    InitCursorCtl(NULL);
  534.    /*
  535.     * To support the icode and iconx interpreter bundled together in
  536.     * the same file, we might have to use this code file as the icode
  537.     * file, too.  We do this if the command name is not 'iconx'.
  538.     */
  539.    {
  540.    char *p,*q,c,fn[6];
  541.  
  542.    /*
  543.     * Isolate the filename from the path.
  544.     */
  545.    q = strrchr(*argv,':');
  546.    if (q == NULL)
  547.        q = *argv;
  548.    else
  549.        ++q;
  550.    /*
  551.     * See if it's the real iconx -- case independent compare.
  552.     */
  553.    p = fn;
  554.    if (strlen(q) == 5)
  555.       while (c = *q++) *p++ = tolower(c);
  556.    *p = '\0';
  557.    if (strcmp(fn,"iconx") != 0) {
  558.      /*
  559.       * This technique of shifting arguments relies on the fact that
  560.       * argv[0] is never referenced, since this will make it invalid.
  561.       */
  562.       --argv;
  563.       ++argc;
  564.       --(*ip);
  565.       /*
  566.        * We don't want to look for any command line options in this
  567.        * case.  They could interfere with options for the icon
  568.        * program.
  569.        */
  570.       NoOptions = 1;
  571.       }
  572.    }
  573. #endif                    /* MPW */
  574. #endif                                  /* MACINTOSH */
  575.  
  576. /*
  577.  * Handle command-line options.
  578. */
  579.  
  580. /*
  581.  * Handle command line options.
  582. */
  583. #if MACINTOSH && MPW
  584.    if (!NoOptions)
  585. #endif                    /* MACINTOSH && MPW */
  586.    while ( argv[1] != 0 && *argv[1] == '-' ) {
  587.       switch ( *(argv[1]+1) ) {
  588.  
  589. #ifdef TallyOpt
  590.     /*
  591.      * Set tallying flag if -T option given
  592.      */
  593.     case 'T':
  594.         tallyopt = 1;
  595.         break;
  596. #endif                    /* TallyOpt */
  597.  
  598.       /*
  599.        * Set stderr to new file if -e option is given.
  600.        */
  601.      case 'e': {
  602.         char *p;
  603.         if ( *(argv[1]+2) != '\0' )
  604.            p = argv[1]+2;
  605.         else {
  606.            argv++;
  607.            argc--;
  608.                (*ip)++;
  609.            p = argv[1];
  610.            if ( !p )
  611.           error("no file name given for redirection of &errout");
  612.            }
  613.         if ( *p == '-' ) { /* let - be stdout */
  614. /*
  615.  * The following code is operating-system dependent [@imain.02].  Redirect
  616.  *  stderr to stdout.
  617.  */
  618.  
  619. #if PORT
  620.    /* may not be possible */
  621. Deliberate Syntax Error
  622. #endif                    /* PORT */
  623.  
  624. #if AMIGA
  625. #if AZTEC_C
  626.         /*
  627.          * Try the same hack as above for Manx and cross fingers.
  628.          * If it doesn't work, try trick used for HIGH_C, below.
  629.          */
  630.         stderr->_unit  = stdout->_unit;
  631.         stderr->_flags = stdout->_flags;
  632. #endif                    /* AZTEC C */
  633. #if LATTICE
  634.                /*
  635.                 * The following code is for Lattice 4.0.  It was different
  636.                 *  for Lattice 3.10 and probably won't work for other
  637.                 *  C compilers.
  638.                 */
  639.            stderr->_file = 1;
  640.            stderr->_flag = stdout->_flag;
  641. #endif                    /* LATTICE */
  642. #endif                    /* AMIGA */
  643.  
  644. #if ATARI_ST || MSDOS || OS2 || VMS
  645.                dup2(fileno(stdout),fileno(stderr));
  646. #endif                    /* ATARI_ST || MSDOS || VMS */
  647.  
  648. #if HIGHC_386
  649.            /*
  650.             * Don't like doing this, but it seems to work.
  651.             */
  652.            setbuf(stdout,NULL);
  653.            setbuf(stderr,NULL);
  654.            stderr->_fd = stdout->_fd;        
  655. #endif                    /* HIGHC_386 */
  656.  
  657. #if MACINTOSH
  658. #if LSC
  659.    /* cannot do */
  660. #endif                    /* LSC */
  661. #if MPW
  662.                close(fileno(stderr));
  663.                dup(fileno(stdout));
  664. #endif                    /* MPW */
  665. #endif                                  /* MACINTOSH */
  666.  
  667. #if MVS || VM
  668.                /* May not be possible. */
  669. #endif                    /* MVS || VM */
  670.  
  671. #if UNIX
  672.                /*
  673.                 * This relies on the way UNIX assigns file numbers.
  674.                 */
  675.                close(fileno(stderr));
  676.                dup(fileno(stdout));
  677. #endif                    /* UNIX */
  678.  
  679. /*
  680.  * End of operating-system specific code.
  681.  */
  682.  
  683.             }
  684.          else    /* redirecting to named file */
  685.             if (freopen(p, "w", stderr) == NULL)
  686.                syserr("Unable to redirect &errout\n");
  687.         break;
  688.         }
  689.         }
  690.     argc--;
  691.         (*ip)++;
  692.     argv++;
  693.       }
  694.    }
  695.  
  696. /*
  697.  * icon_init - initialize memory and prepare for Icon execution.
  698.  */
  699.  
  700. novalue icon_init(name)
  701. char *name;
  702.    {
  703.    int n;
  704.    struct header hdr;
  705.    FILE *fname = NULL;
  706.    word cbread, longread();
  707.    extern struct astkblk *alcactiv();
  708.  
  709.    /*
  710.     * Catch floating point traps and memory faults.
  711.     */
  712.  
  713. /*
  714.  * The following code is operating-system dependent [@imain.03].  Set traps.
  715.  */
  716.  
  717. #if PORT
  718.    /* probably needs something */
  719. Deliberate Syntax Error
  720. #endif                    /* PORT */
  721.  
  722. #if AMIGA
  723.    signal(SIGFPE,fpetrap);
  724. #endif                    /* AMIGA */
  725.  
  726. #if ATARI_ST
  727. #endif                    /* ATARI_ST */
  728.  
  729. #if HIGHC_386
  730.    /* signals not supported */
  731. #endif                    /* HIGHC_386 */
  732.  
  733. #if MACINTOSH
  734. #if MPW
  735.    /* This is equivalent to SIGFPE signal in the Standard Apple
  736.       Numeric Environment (SANE) */
  737.    {
  738.    environment e;
  739.    getenvironment(&e);
  740. #ifdef mc68881
  741.       e.FPCR |= CURUNDERFLOW|CUROVERFLOW|CURDIVBYZERO;
  742. #else                    /* mc68881 */
  743.       e |= UNDERFLOW|OVERFLOW|DIVBYZERO;
  744. #endif                    /* mc68881 */
  745.    setenvironment(e);
  746. #ifdef mc68881
  747.       {
  748.       static trapvector tv =
  749.          {fpetrap,fpetrap,fpetrap,fpetrap,fpetrap,fpetrap,fpetrap};
  750.       settrapvector(&tv);
  751.       }
  752. #else                    /* mc6881 */
  753.       sethaltvector((haltvector)fpetrap);
  754. #endif                    /* mc6881 */
  755.    }
  756. #endif                    /* MPW */
  757. #endif                    /* MACINTOSH */
  758.  
  759. #if MSDOS
  760. #if LATTICE || MICROSOFT || TURBO
  761.    signal(SIGFPE, fpetrap);
  762. #endif                    /* LATTICE || MICROSOFT || TURBO */
  763. #endif                    /* MSDOS */
  764.  
  765. #if OS2
  766.    signal(SIGFPE, fpetrap);
  767.    signal(SIGSEGV, segvtrap);
  768. #endif                    /* OS2 */
  769.  
  770. #if MVS || VM
  771.    signal(SIGPFE, fpetrap);
  772.    signal(SIGFIX, fixtrap);
  773. #endif                    /* MVS || VM */
  774.  
  775. #if UNIX || VMS
  776.    signal(SIGSEGV, segvtrap);
  777. #ifdef PYRAMID
  778.    {
  779.    struct sigvec a;
  780.  
  781.    a.sv_handler = fpetrap;
  782.    a.sv_mask = 0;
  783.    a.sv_onstack = 0;
  784.    sigvec(SIGFPE, &a, 0);
  785.    sigsetmask(1 << SIGFPE);
  786.    }
  787. #else                    /* PYRAMID */
  788.    signal(SIGFPE, fpetrap);
  789. #endif                    /* PYRAMID */
  790. #endif                    /* UNIX || VMS */
  791.  
  792. /*
  793.  * End of operating-system specific code.
  794.  */
  795.  
  796. #ifdef ExecImages
  797.    /*
  798.     * If reloading from a dumped out executable, skip most of init and
  799.     *  just set up the buffer for stderr and do the timing initializations.
  800.     */
  801.    if (dumped)
  802.        goto btinit;
  803. #endif                    /* ExecImages */
  804.  
  805.    /*
  806.     * Initialize data that can't be intialized statically.
  807.     */
  808.  
  809.    datainit();
  810.  
  811.    /*
  812.     * Open the icode file and read the header.        [[I?]]
  813.     */
  814.  
  815.    if (!name)
  816.       error("no interpreter file supplied");
  817.  
  818.    /*
  819.     * Try adding the suffix if the file name doesn't end in it.
  820.     */
  821.    n = strlen(name);
  822.    if (n <= 4 || (strcmp(name+n-4,IcodeSuffix) != 0)
  823.    && strcmp(name+n-4,IcodeASuffix) != 0) {
  824.       char tname[100];
  825.       if (strlen(name) + 5 > 100)
  826.          error("icode file name too long");
  827.       strcpy(tname,name);
  828.  
  829. #ifdef WATERLOO_C_V3_0
  830.       strcat(tname," ICX * (BIN");
  831.       fname = fopen(tname,"r");
  832. #else                    /* WATERLOO_C_V3_0 */
  833.       strcat(tname,IcodeSuffix);
  834.       fname = fopen(tname,ReadBinary);
  835. #endif                    /* WATERLOO_C_V3_0 */
  836.       }
  837.  
  838.    if (fname == NULL)                /* try the name as given */
  839.  
  840. #ifdef WATERLOO_C_V3_0
  841.       {
  842.       /*
  843.        *  Prevent interpretation of \n in binary files.
  844.        */
  845.       char tname[100];
  846.       strcpy(tname,name);
  847.       strcat(tname," (BIN");
  848.       fname = fopen(tname,"r");
  849.       }
  850. #else                    /* WATERLOO_C_V3_0 */
  851.       fname = fopen(name,ReadBinary);
  852. #endif                    /* WATERLOO_C_V3_0 */
  853.  
  854.    if (fname == NULL)
  855.       error("cannot open interpreter file");
  856.  
  857.    setbuf(fname,icodebuf);
  858.  
  859.    {
  860.    static char errmsg[] = "can't read interpreter file header";
  861. #ifdef Header
  862.    if (fseek(fname, (long)MaxHeader, 0) == -1)
  863.       error(errmsg);
  864. #endif                    /* Header */
  865.  
  866.    if (fread((char *)&hdr, sizeof(char), sizeof(hdr), fname) != sizeof(hdr))
  867.       error(errmsg);
  868.    }
  869.  
  870.    k_trace = hdr.trace;
  871.  
  872.  
  873. #ifdef EnvVars
  874.    /*
  875.     * Examine the environment and make appropriate settings.    [[I?]]
  876.     */
  877.    envset();
  878. #endif                    /* EnvVars */
  879.  
  880.    /*
  881.     * Convert stack sizes from words to bytes.
  882.     */
  883.  
  884. #ifndef SCO_XENIX
  885.    stksize *= WordSize;
  886.    mstksize *= WordSize;
  887. #else                    /* SCO_XENIX */
  888.    /*
  889.     * This is a work-around for bad generated code for *= (as above)
  890.     *  produced by the SCO XENIX C Compiler for the large memory model.
  891.     *  It relies on the fact that WordSize is 4.
  892.     */
  893.    stksize += stksize;
  894.    stksize += stksize;
  895.    mstksize += mstksize;
  896.    mstksize += mstksize;
  897. #endif                    /* SCO_XENIX */
  898.  
  899. #if IntBits == 16
  900.    if (mstksize > MaxBlock)
  901.       fatalerr(-316, NULL);
  902.    if (stksize > MaxBlock)
  903.       fatalerr(-318, NULL);
  904. #endif                    /* IntBits == 16 */
  905.  
  906.    /*
  907.     * Allocate memory for various regions.
  908.     */
  909.    initalloc(hdr.hsize);
  910.  
  911.    /*
  912.     * Establish pointers to icode data regions.        [[I?]]
  913.     */
  914.  
  915.    records = (word *)(code + hdr.records);
  916.    ftabp = (word *)(code + hdr.ftab);
  917.    fnames = (dptr)(code + hdr.fnames);
  918.    globals = efnames = (dptr)(code + hdr.globals);
  919.    gnames = eglobals = (dptr)(code + hdr.gnames);
  920.    statics = egnames = (dptr)(code + hdr.statics);
  921.    estatics = (dptr)(code + hdr.filenms);
  922.    filenms = (struct ipc_fname *)estatics;
  923.    efilenms = (struct ipc_fname *)(code + hdr.linenums);
  924.    ilines = (struct ipc_line *)efilenms;
  925.    elines = (struct ipc_line *)(code + hdr.strcons);
  926.    strcons = (char *)elines;
  927.  
  928.    /*
  929.     * Allocate stack and initialize &main.
  930.     */
  931.  
  932.    stack = (word *)malloc((msize)mstksize);
  933.    if (stack == NULL)
  934.       fatalerr(-303, NULL);
  935.    mainhead = (struct b_coexpr *)stack;
  936.    mainhead->title = T_Coexpr;
  937.  
  938. #ifdef Coexpr
  939.    mainhead->es_actstk = alcactiv();
  940.    if (mainhead->es_actstk == NULL)
  941.       fatalerr(0, NULL);
  942.    if (pushact(mainhead, mainhead) == Error)
  943.       fatalerr(0, NULL);
  944. #endif                    /* Coexpr */
  945.  
  946.    mainhead->id = 1;
  947.    mainhead->size = 1;            /* pretend main() does an activation */
  948.  
  949.    mainhead->freshblk = nulldesc;    /* &main has no refresh block. */
  950.                     /*  This really is a bug. */
  951.  
  952.    /*
  953.     * Point &main at the co-expression block for the main procedure and set
  954.     *  k_current, the pointer to the current co-expression, to &main.
  955.     */
  956.    k_main.dword = D_Coexpr;
  957.    BlkLoc(k_main) = (union block *) mainhead;
  958.    k_current = k_main;
  959.    
  960.    /*
  961.     * Read the interpretable code and data into memory.
  962.     */
  963.  
  964.    if ((cbread = longread(code, sizeof(char), (long)hdr.hsize, fname)) !=
  965.       hdr.hsize) {
  966.       fprintf(stderr,"Tried to read %ld bytes of code, got %ld\n",
  967.     (long)hdr.hsize,(long)cbread);
  968.       error("can't read interpreter code");
  969.       }
  970.    fclose(fname);
  971.  
  972. /*
  973.  * Make sure the version number of the icode matches the interpreter version.
  974.  */
  975.  
  976.    if (strcmp((char *)hdr.config,IVersion)) {
  977.       fprintf(stderr,"icode version mismatch\n");
  978.       fprintf(stderr,"\ticode version: %s\n",(char *)hdr.config);
  979.       fprintf(stderr,"\texpected version: %s\n",IVersion);
  980.       error("cannot run");
  981.       }
  982.  
  983.    /*
  984.     * Resolve references from icode to run-time system.
  985.     */
  986.    resolve();
  987.  
  988. #ifdef ExecImages
  989. btinit:
  990. #endif                    /* ExecImages */
  991.  
  992. /*
  993.  * The following code is operating-system dependent [@imain.04].  Allocate and
  994.  *  assign a buffer to stderr if possible.
  995.  */
  996.  
  997. #if PORT
  998.    /* probably nothing */
  999. Deliberate Syntax Error
  1000. #endif                    /* PORT */
  1001.  
  1002. #if AMIGA || HIGHC_386 || MVS || VM
  1003.    /* not done */
  1004. #endif                    /* AMIGA */
  1005.  
  1006. #if ATARI_ST || MACINTOSH || UNIX || MSDOS || OS2 || VMS
  1007.  
  1008.    if (noerrbuf)
  1009.       setbuf(stderr, NULL);
  1010.    else {
  1011.       char *buf;
  1012.       
  1013.       buf = (char *)malloc((msize)BUFSIZ);
  1014.       if (buf == NULL)
  1015.         fatalerr(-305, NULL);
  1016.       setbuf(stderr, buf);
  1017.       }
  1018. #endif                    /* ATARI_ST || MACINTOSH || UNIX ... */
  1019.  
  1020. /*
  1021.  * End of operating-system specific code.
  1022.  */
  1023.  
  1024. #ifdef MemMon
  1025.    /*
  1026.     * Initialize the memory monitoring system, if configured.
  1027.     */
  1028.    MMInit(name);
  1029. #endif                    /* MemMon */
  1030.  
  1031. #ifdef EvalTrace
  1032.    /*
  1033.     * Initialize evaluation tracing system
  1034.     */
  1035.    TRInit(name);
  1036. #endif                    /* EvalTrace */
  1037.  
  1038.    /*
  1039.     * Start timing execution.
  1040.     */
  1041.  
  1042.    millisec();
  1043.    }
  1044.  
  1045. /*
  1046.  * Service routines related to getting things started.
  1047.  */
  1048.  
  1049. /*
  1050.  * resolve - perform various fix-ups on the data read from the icode
  1051.  *  file.
  1052.  */
  1053. novalue resolve()
  1054.    {
  1055.    register word i;
  1056.    register struct b_proc *pp;
  1057.    register dptr dp;
  1058.    extern Omkrec();
  1059.    extern int ftsize;
  1060.  
  1061.    extern struct b_proc *functab[];
  1062.  
  1063.    /*
  1064.     * Scan the global variable array for procedures and fill in appropriate
  1065.     *  addresses.
  1066.     */
  1067.    for (dp = globals; dp < eglobals; dp++) {
  1068.       if ((*dp).dword != D_Proc)
  1069.          continue;
  1070.  
  1071.       /*
  1072.        * The second word of the descriptor for procedure variables tells
  1073.        *  where the procedure is.  Negative values are used for built-in
  1074.        *  procedures and positive values are used for Icon procedures.
  1075.        */
  1076.       i = IntVal(*dp);
  1077.  
  1078.       if (i < 0) {
  1079.          /*
  1080.           * *dp names a built-in function, negate i and use it as an index
  1081.           *  into functab to get the location of the procedure block.
  1082.           */
  1083.          i = -i;
  1084.          if (i > ftsize) {
  1085.             *dp = nulldesc;        /* undefined, set to &null */
  1086.             continue;
  1087.             }
  1088.          BlkLoc(*dp) = (union block *)functab[i-1];
  1089.          }
  1090.       else {
  1091.  
  1092.          /*
  1093.           * *dp names an Icon procedure or a record.  i is an offset to
  1094.           *  location of the procedure block in the code section.  Point
  1095.           *  pp at the block and replace BlkLoc(*dp).
  1096.           */
  1097.          pp = (struct b_proc *)(code + i);
  1098.          BlkLoc(*dp) = (union block *)pp;
  1099.  
  1100.          /*
  1101.           * Relocate the address of the name of the procedure.
  1102.           */
  1103.          StrLoc(pp->pname) = strcons + (uword)StrLoc(pp->pname);
  1104.          if (pp->ndynam == -2)
  1105.             /*
  1106.              * This procedure is a record constructor.    Make its entry point
  1107.              *    be the entry point of Omkrec().
  1108.              */
  1109.             pp->entryp.ccode = Omkrec;
  1110.          else {
  1111.             /*
  1112.              * This is an Icon procedure.  Relocate the entry point and
  1113.              *    the names of the parameters, locals, and static variables.
  1114.              */
  1115.             pp->entryp.icode = code + pp->entryp.ioff;
  1116.             for (i = 0; i < abs((int)pp->nparam)+pp->ndynam+pp->nstatic; i++)
  1117.                StrLoc(pp->lnames[i]) = strcons + (uword)StrLoc(pp->lnames[i]);
  1118.             }
  1119.  
  1120. #ifndef BoundFunctions
  1121.          }
  1122. #endif                    /* BoundFunctions */
  1123.  
  1124.       }
  1125.  
  1126.    /*
  1127.     * Relocate the names of the fields.
  1128.     */
  1129.  
  1130.    for (dp = fnames; dp < efnames; dp++)
  1131.       StrLoc(*dp) = strcons + (uword)StrLoc(*dp);
  1132.  
  1133.    /*
  1134.     * Relocate the names of the global variables.
  1135.     */
  1136.    for (dp = gnames; dp < egnames; dp++)
  1137.       StrLoc(*dp) = strcons + (uword)StrLoc(*dp);
  1138.  
  1139.    }
  1140.  
  1141. #ifdef EnvVars
  1142. /*
  1143.  * Check for environment variables that Icon uses and set system
  1144.  *  values as is appropriate.
  1145.  */
  1146. novalue envset()
  1147.    {
  1148.    register char *p;
  1149.  
  1150.    if ((p = getenv("NOERRBUF")) != NULL)
  1151.       noerrbuf++;
  1152.    env_int("TRACE", &k_trace, 0, (uword)0);
  1153.    env_int("COEXPSIZE", &stksize, 1, (uword)MaxUnsigned);
  1154.    env_int("STRSIZE", &ssize, 1, (uword)MaxBlock);
  1155.    env_int("HEAPSIZE", &abrsize, 1, (uword)MaxBlock);
  1156.    env_int("BLOCKSIZE", &abrsize, 1, (uword)MaxBlock);    /* synonym */
  1157.    env_int("BLKSIZE", &abrsize, 1, (uword)MaxBlock);    /* synonym */
  1158.    env_int("STATSIZE", &statsize, 1, (uword)MaxBlock);
  1159.    env_int("STATINCR", &statincr, 1, (uword)MaxBlock);
  1160.    env_int("MSTKSIZE", &mstksize, 1, (uword)MaxUnsigned);
  1161.  
  1162. #ifdef FixedRegions
  1163.    env_int("QLSIZE", &qualsize, 1, (uword)MaxBlock);
  1164. #endif                    /* FixedRegions */
  1165.  
  1166. /*
  1167.  * The following code is operating-system dependent [@imain.05].  Check any
  1168.  *  system-dependent environment variables.
  1169.  */
  1170.  
  1171. #if PORT
  1172.    /* nothing to do */
  1173. Deliberate Syntax Error
  1174. #endif                    /* PORT */
  1175.  
  1176. #if AMIGA
  1177.    if ((p = getenv("CHECKBREAK")) != NULL)
  1178.       chkbreak++;
  1179. #endif                    /* AMIGA */
  1180.  
  1181. #if ATARI_ST || HIGHC_386 || MACINTOSH || MSDOS || MVS || OS2 || UNIX || VM
  1182.    /* nothing to do */
  1183. #endif                    /* ATARI_ST || HIGHC_386 || ... */
  1184.  
  1185. #if VMS
  1186.    {
  1187.       extern word memsize;
  1188.       env_int("MAXMEM", &memsize, 1, MaxBlock);
  1189.    }
  1190. #endif                    /* VMS */
  1191.  
  1192. /*
  1193.  * End of operating-system specific code.
  1194.  */
  1195.  
  1196.    if ((p = getenv("ICONCORE")) != NULL && *p != '\0') {
  1197.  
  1198. /*
  1199.  * The following code is operating-system dependent [@imain.06].  Set trap to
  1200.  *  give dump on abnormal termination if ICONCORE is set.
  1201.  */
  1202.  
  1203. #if PORT
  1204.    /* can't handle */
  1205. Deliberate Syntax Error
  1206. #endif                    /* PORT */
  1207.  
  1208. #if AMIGA || ATARI_ST || HIGHC_386 || MACINTOSH
  1209.    /* can't handle */
  1210. #endif                    /* AMIGA || ATARI_ST || ... */
  1211.  
  1212. #if MSDOS
  1213. #if LATTICE || TURBO
  1214.       signal(SIGFPE, SIG_DFL);
  1215. #endif                    /* LATTICE || TURBO */
  1216. #endif                    /* MSDOS */
  1217.  
  1218. #if MVS || VM
  1219.       /* Really nothing to do. */
  1220. #endif                    /* MVS || VM */
  1221.  
  1222. #if OS2
  1223.       signal(SIGSEGV, SIG_DFL);
  1224.       signal(SIGFPE, SIG_DFL);
  1225. #endif                    /* OS2 */
  1226.  
  1227. #if UNIX || VMS
  1228.       signal(SIGSEGV, SIG_DFL);
  1229. #endif                    /* UNIX || VMS */
  1230.  
  1231. /*
  1232.  * End of operating-system specific code.
  1233.  */
  1234.       dodump++;
  1235.       }
  1236.    }
  1237.  
  1238. static novalue env_err(msg, name, val)
  1239. char *msg;
  1240. char *name;
  1241. char *val;
  1242. {
  1243.    char msg_buf[100];
  1244.  
  1245.    strncpy(msg_buf, msg, 99);
  1246.    strncat(msg_buf, ": ", 99 - strlen(msg_buf));
  1247.    strncat(msg_buf, name, 99 - strlen(msg_buf));
  1248.    strncat(msg_buf, "=", 99 - strlen(msg_buf));
  1249.    strncat(msg_buf, val, 99 - strlen(msg_buf));
  1250.    error(msg_buf);
  1251. }
  1252.  
  1253. /*
  1254.  * env_int - get the value of an integer-valued environment variable.
  1255.  */
  1256. novalue env_int(name, variable, non_neg, limit)
  1257. char *name;
  1258. word *variable;
  1259. int non_neg;
  1260. uword limit;
  1261. {
  1262.    char *value;
  1263.    char *s;
  1264.    register uword n = 0;
  1265.    register uword d;
  1266.    int sign = 1;
  1267.  
  1268.    if ((value = getenv(name)) == NULL || *value == '\0')
  1269.       return;
  1270.  
  1271.    s = value;
  1272.    if (*s == '-') {
  1273.       if (non_neg)
  1274.          env_err("environment variable out of range", name, value);
  1275.       sign = -1;
  1276.       ++s;
  1277.       }
  1278.    else if (*s == '+')
  1279.       ++s;
  1280.    while (isdigit(*s)) {
  1281.       d = *s++ - '0';
  1282.       /*
  1283.        * See if 10 * n + d > limit, but do it so there can be no overflow.
  1284.        */
  1285.       if ((d > (uword)(limit / 10 - n) * 10 + limit % 10) && (limit > 0))
  1286.      env_err("environment variable out of range", name, value);
  1287.       n = n * 10 + d;
  1288.       }
  1289.    if (*s != '\0')
  1290.       env_err("environment variable not numeric", name, value);
  1291.    *variable = sign * n;
  1292. }
  1293. #endif                    /* EnvVars */
  1294.  
  1295. /*
  1296.  * Termination routines.
  1297.  */
  1298.  
  1299. /*
  1300.  * Produce run-time error 204 on floating-point traps.
  1301.  */
  1302.  
  1303. novalue fpetrap()
  1304.    {
  1305.    fatalerr(-204, NULL);
  1306.    }
  1307.  
  1308. /*
  1309.  * Produce run-time error 320 on ^C interrupts. Not used at present,
  1310.  *  since malfunction may occur during traceback.
  1311.  */
  1312. novalue inttrap()
  1313.    {
  1314.    fatalerr(-320, NULL);
  1315.    }
  1316.  
  1317. /*
  1318.  * Produce run-time error 302 on segmentation faults.
  1319.  */
  1320. novalue segvtrap()
  1321.    {
  1322.    fatalerr(-302, NULL);
  1323.    }
  1324.  
  1325. #if MVS || VM
  1326. novalue fixtrap()
  1327.    {
  1328.    fatalerror(-203, NULL);
  1329.    }
  1330. #endif                    /* MVS || VM */
  1331.  
  1332. /*
  1333.  * error - print error message s; used only in startup code.
  1334.  */
  1335. novalue error(s)
  1336. char *s;
  1337.    {
  1338.  
  1339.  
  1340.    fprintf(stderr, "error in startup code\n%s\n", s);
  1341.  
  1342.    fflush(stderr);
  1343.    if (dodump)
  1344.       abort();
  1345.    c_exit(ErrorExit);
  1346.    }
  1347.  
  1348. /*
  1349.  * syserr - print s as a system error.
  1350.  */
  1351. novalue syserr(s)
  1352. char *s;
  1353.    {
  1354.  
  1355.    
  1356.    if (pfp != 0)
  1357.       fprintf(stderr, "System error at line %ld in %s\n%s\n",
  1358.          (long)findline(ipc.opnd), findfile(ipc.opnd), s);
  1359.    else
  1360.       fprintf(stderr, "System error in startup code\n%s\n", s);
  1361.  
  1362.    fflush(stderr);
  1363.    if (dodump)
  1364.       abort();
  1365.    c_exit(ErrorExit);
  1366.    }
  1367.  
  1368. /*
  1369.  * runerr - print message corresponding to error |n|;  if n > 0,
  1370.  *  print it as the offending value.
  1371.  */
  1372.  
  1373. novalue runerr(n, v)
  1374.  
  1375. register int n;
  1376. dptr v;
  1377.    {
  1378.    register struct errtab *p;
  1379.  
  1380.    if (n != 0) {
  1381.       k_errornumber = n;
  1382.       if (n > 0)
  1383.          k_errorvalue = *v;
  1384.       else
  1385.          k_errorvalue = nulldesc;
  1386.       }
  1387.  
  1388.    /*
  1389.     * Take absolute value of error number
  1390.     */
  1391.    n = (k_errornumber > 0 ? k_errornumber : -k_errornumber);
  1392.  
  1393.    k_errortext = "";
  1394.    for (p = errtab; p->err_no > 0; p++)
  1395.       if (p->err_no == n) {
  1396.          k_errortext = p->errmsg;
  1397.          break;
  1398.          }
  1399.  
  1400.  
  1401.    if (pfp != 0) {
  1402.       if (k_error == 0) {
  1403.          fprintf(stderr, "Run-time error %d\nFile %s; Line %ld\n",
  1404.             n, findfile(ipc.opnd), (long)findline(ipc.opnd));
  1405.          }
  1406.       else {
  1407.          k_error--;
  1408.          return;
  1409.          }
  1410.       }
  1411.    else
  1412.       fprintf(stderr, "Run-time error %d in startup code\n", n);
  1413.    fprintf(stderr, "%s\n", k_errortext);
  1414.  
  1415.    if (k_errornumber > 0) {
  1416.       fprintf(stderr, "offending value: ");
  1417.       outimage(stderr, &k_errorvalue, 0);
  1418.       putc('\n', stderr);
  1419.       }
  1420.    fflush(stderr);
  1421.  
  1422. #ifdef MemMon
  1423.    {
  1424.       char buf[40];
  1425.       sprintf(buf,"Run-time error %d: ",n);
  1426.       MMTerm(buf,k_errortext);
  1427.    }
  1428. #endif                /* MemMon */
  1429.  
  1430. #ifdef EvalTrace
  1431.    {
  1432.       char buf[40];
  1433.       sprintf(buf,"Run-time error %d: ",n);
  1434.       TRTerm(buf,k_errortext);
  1435.    }
  1436. #endif                /* EvalTrace */
  1437.  
  1438. #ifdef TraceBack
  1439.    if (pfp == 0) {        /* skip if start-up problem */
  1440.       if (dodump)
  1441.          abort();
  1442.       c_exit(ErrorExit);
  1443.       }
  1444.  
  1445.    {
  1446.    struct pf_marker *origpfp = pfp;
  1447.    dptr arg;
  1448.    struct b_proc *cproc;
  1449.    inst cipc;
  1450.  
  1451.    fprintf(stderr, "Trace back:\n");
  1452.  
  1453.    /*
  1454.     * Chain back through the procedure frame markers, looking for the
  1455.     *  first one, while building a foward chain of pointers through
  1456.     *  the expression frame pointers.
  1457.     */
  1458.  
  1459.    for (pfp->pf_efp = NULL; pfp->pf_pfp != NULL; pfp = pfp->pf_pfp) {
  1460.       (pfp->pf_pfp)->pf_efp = (struct ef_marker *)pfp;
  1461.       }
  1462.  
  1463.    /* Now start from the base procedure frame marker, producing a listing
  1464.     *  of the procedure calls up through the last one.
  1465.     */
  1466.  
  1467.    while (pfp) {
  1468.       arg = &((dptr)pfp)[-(pfp->pf_nargs) - 1];
  1469.       cproc = (struct b_proc *)BlkLoc(arg[0]);    
  1470.       /*
  1471.        * The ipc in the procedure frame points after the "invoke n".
  1472.        */
  1473.       cipc = pfp->pf_ipc;
  1474.       --cipc.opnd;
  1475.       --cipc.op;
  1476.  
  1477.       xtrace(cproc, pfp->pf_nargs, &arg[0], findline(cipc.opnd),
  1478.          findfile(cipc.opnd));
  1479.       /*
  1480.        * On the last call, show both the call and the offending expression.
  1481.        */
  1482.       if (pfp == origpfp) {
  1483.          ttrace();
  1484.          break;
  1485.          }
  1486.  
  1487.       pfp = (struct pf_marker *)(pfp->pf_efp);
  1488.       }
  1489.    }
  1490. #endif                     /* TraceBack */
  1491.  
  1492.  
  1493.    if (dodump)
  1494.       abort();
  1495.    c_exit(ErrorExit);
  1496.    }
  1497.  
  1498. /*
  1499.  * c_exit(i) - flush all buffers and exit with status i.
  1500.  */
  1501. novalue c_exit(i)
  1502. int i;
  1503. {
  1504.  
  1505. #ifdef MemMon
  1506.    MMTerm("","");
  1507. #endif                    /* MemMon */
  1508.  
  1509. #ifdef EvalTrace
  1510.    TRTerm("","");
  1511. #endif                    /* EvalTrace */
  1512.  
  1513. #ifdef TallyOpt
  1514.    {
  1515.    int j;
  1516.  
  1517.    if (tallyopt) {
  1518.       fprintf(stderr,"tallies: ");
  1519.       for (j=0; j<16; j++)
  1520.          fprintf(stderr," %ld", (long)tallybin[j]);
  1521.          fprintf(stderr,"\n");
  1522.          }
  1523.       }
  1524. #endif                    /* TallyOpt */
  1525.  
  1526.  
  1527.    exit(i);
  1528. }
  1529.  
  1530. /*
  1531.  * err() is called if an erroneous situation occurs in the virtual
  1532.  *  machine code.  It is typed as int to avoid declaration problems
  1533.  *  elsewhere.
  1534.  */
  1535. int err()
  1536. {
  1537.    syserr("call to 'err'\n");
  1538.    return 1;        /* unreachable; make compilers happy */
  1539. }
  1540.  
  1541. novalue fatalerr(n, v)
  1542. int n;
  1543. dptr v;
  1544.    {
  1545.    k_error = 0;
  1546.    runerr(n, v);
  1547.    }
  1548.  
  1549. novalue datainit()
  1550.    {
  1551.  
  1552.    /*
  1553.     * Initializations that cannot be performed statically (at least for
  1554.     * some compilers).                    [[I?]]
  1555.     */
  1556.  
  1557.    k_errout.fd = stderr;
  1558.    k_errout.fname.dword = 7;
  1559.    StrLoc(k_errout.fname) = "&errout";
  1560.    k_errout.status = Fs_Write;
  1561.  
  1562.    k_input.fd = stdin;
  1563.    k_input.fname.dword = 6;
  1564.    StrLoc(k_input.fname) = "&input";
  1565.    k_input.status = Fs_Read;
  1566.  
  1567.    k_output.fd = stdout;
  1568.    k_output.fname.dword = 7;
  1569.    StrLoc(k_output.fname) = "&output";
  1570.    k_output.status = Fs_Write;
  1571.  
  1572.    IntVal(tvky_pos.kyval) = 1;
  1573.    StrLen(tvky_pos.kyname) = 4;
  1574.    StrLoc(tvky_pos.kyname) = "&pos";
  1575.  
  1576.    IntVal(tvky_ran.kyval) = 0;
  1577.    StrLen(tvky_ran.kyname) = 7;
  1578.    StrLoc(tvky_ran.kyname) = "&random";
  1579.  
  1580.    StrLen(tvky_sub.kyval) = 0;
  1581.    StrLoc(tvky_sub.kyval) = "";
  1582.    StrLen(tvky_sub.kyname) = 8;
  1583.    StrLoc(tvky_sub.kyname) = "&subject";
  1584.  
  1585.    IntVal(tvky_trc.kyval) = 0;
  1586.    StrLen(tvky_trc.kyname) = 6;
  1587.    StrLoc(tvky_trc.kyname) = "&trace";
  1588.  
  1589.    IntVal(tvky_err.kyval) = 0;
  1590.    StrLen(tvky_err.kyname) = 6;
  1591.    StrLoc(tvky_err.kyname) = "&error";
  1592.  
  1593.  
  1594.    StrLen(blank) = 1;
  1595.    StrLoc(blank) = " ";
  1596.    StrLen(emptystr) = 0;
  1597.    StrLoc(emptystr) = "";
  1598.    BlkLoc(errout) = (union block *) &k_errout;
  1599.    BlkLoc(input) = (union block *) &k_input;
  1600.    StrLen(lcase) = 26;
  1601.    StrLoc(lcase) = "abcdefghijklmnopqrstuvwxyz";
  1602.    StrLen(letr) = 1;
  1603.    StrLoc(letr) = "r";
  1604.    IntVal(nulldesc) = 0;
  1605.    k_errorvalue = nulldesc;
  1606.    IntVal(onedesc) = 1;
  1607.    StrLen(ucase) = 26;
  1608.    StrLoc(ucase) = "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
  1609.    IntVal(zerodesc) = 0;
  1610.  
  1611.    maps2 = nulldesc;
  1612.    maps3 = nulldesc;
  1613.  
  1614. #ifdef MultipleRuns
  1615.  
  1616.    mstksize = MStackSize;        /* initial size of main stack */
  1617.    stksize = StackSize;            /* co-expression stack size */
  1618.    ssize = MaxStrSpace;            /* initial string space size (bytes) */
  1619.    abrsize = MaxAbrSize;        /* initial size of allocated block
  1620.                          region (bytes) */                                    
  1621. #ifdef FixedRegions
  1622.    qualsize = QualLstSize;        /* size of quallist for fixed regions */
  1623. #endif                    /* FixedRegions */
  1624.  
  1625.    ntended = 0;                /* number of active tended descrips */
  1626.    dodump = 0;                /* produce dump on error */
  1627.    mterm = Op_Quit;
  1628.  
  1629. #ifdef IconCalling
  1630.    fterm = Op_FQuit;
  1631. #endif                    /* IconCalling */
  1632.  
  1633. #ifdef ExecImages
  1634.    dumped = 0;                /* This is a dumped image. */
  1635. #endif                    /* ExecImages */
  1636.  
  1637.                     /* In module interp.c:    */
  1638.    pfp = 0;                /* Procedure frame pointer */
  1639.    sp = NULL;                /* Stack pointer */
  1640.  
  1641.  
  1642.                     /* In module rmemmgt.c:    */
  1643.    coexp_ser = 2;
  1644.    list_ser = 1;
  1645.    set_ser = 1;
  1646.    table_ser = 1;
  1647.  
  1648.    coll_stat = 0;
  1649.    coll_str = 0;
  1650.    coll_blk = 0;
  1651.    coll_tot = 0;
  1652.    
  1653.  
  1654. #endif                    /* MultipleRuns */
  1655.    }
  1656.  
  1657.